home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / db.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  23.8 KB  |  766 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module db)
  13.  
  14. (LOAD-MACSYMA-MACROS MRGMAC)
  15.  
  16. ;; This file uses its own special syntax which is set up here.  The function
  17. ;; which does it is defined in LIBMAX;MRGMAC.  It sets up <, >, and : for
  18. ;; structure manipulation.  A major bug with this package is that the code is
  19. ;; almost completely uncommented.  Someone with nothing better to do should go
  20. ;; through it, figure out how it works, and write it down.
  21. ;; Note: After recompiling all of macsyma for the Lispm it was found
  22. ;;       that some files were compiled with the syntax of ":" set up
  23. ;;       incorrectly. The (MODE-SYNTAX-OFF) function, which calls
  24. ;;       undocumented system-internal routines evidently did not work anymore.
  25. ;;       Therefore I removed the need for MODE-SYNTAX-ON from this file.
  26. ;;       7:57pm  Thursday, 25 February 1982 -GJC
  27.  
  28.  
  29. ;; On systems which cons fixnums, a fixnum is used as a single label cell
  30. ;; and a pointer to the fixnum is passed around (i.e. the particular fixnum
  31. ;; is passed around.  On systems which have immediate fixnums, a single cons
  32. ;; cell is created and the fixnum is stored in the car of the cell.  Fixnums
  33. ;; are consed only in PDP-10 MacLisp and Franz Lisp.
  34.  
  35. #+(OR PDP10 Franz)
  36. (EVAL-WHEN (EVAL COMPILE) (SSTATUS FEATURE FIXCONS))
  37. #+NIL
  38. (EVAL-WHEN (EVAL COMPILE) (SET-NOFEATURE 'FIXCONS))
  39.  
  40. (DECLARE-TOP(GENPREFIX DB)
  41.      ;; LAB is not a special.  This declares all occurrences of LAB
  42.      ;; as a local or a parameter to be a fixnum.  This should really
  43.      ;; be done using a LOCAL-DECLARE around the entire file so as to
  44.      ;; make sure any global compiler state gets undone.
  45.      #+FIXCONS (FIXNUM LAB)
  46.      (*LEXPR CONTEXT))
  47.  
  48. ;; External specials
  49. ;; Please do not use DEFMVAR on these because some of them contain 
  50. ;; circular list structure, and we want to be able to load in the 
  51. ;; English version of the file at times.  (DEFMVAR tries to print 
  52. ;; out their values when the value in core is different from the 
  53. ;; value in the file.) - JPG
  54. ;; Why don't you set PRINLEVEL and PRINLENGTH in your macsyma? -GJC
  55.  
  56. (DEFMVAR CONTEXT 'GLOBAL)
  57. (DEFMVAR CONTEXTS NIL)
  58. (DEFMVAR CURRENT 'GLOBAL)
  59. (DEFMVAR +LABS NIL)
  60. (DEFMVAR -LABS NIL)
  61. (DEFMVAR DBTRACE NIL)
  62. (DEFMVAR DBCHECK NIL)
  63. (DEFMVAR DOBJECTS NIL)
  64. (DEFMVAR NOBJECTS NIL)
  65.  
  66. ;; Internal specials
  67.  
  68. (DEFMVAR MARKS 0)         
  69. (DECLARE-top (FIXNUM MARKS))
  70. (DEFMVAR +L)
  71. (DECLARE-top (FIXNUM +L))
  72. (DEFMVAR -L)
  73. (DECLARE-TOP (FIXNUM -L))
  74. (DEFMVAR ULABS NIL)
  75.  
  76. (DEFMVAR CONINDEX 0)
  77. (DECLARE-TOP (FIXNUM CONINDEX))
  78. (DEFMVAR CONNUMBER 50.)
  79. (declare-top (FIXNUM CONNUMBER))
  80.  
  81. ;; The most negative fixnum.  On the PDP-10, this is 1_35.
  82.  
  83. (DEFMVAR LAB-HIGH-BIT #-cl (ROT 1 -1) #+cl most-negative-fixnum)
  84. ;; One less than the number of bits in a fixnum.  On the PDP-10, this is 35.
  85. (DEFMVAR LABNUMBER (f1- (HAULONG LAB-HIGH-BIT)))
  86. ;; A cell with the high bit turned on.
  87. (DEFMVAR LAB-HIGH-LAB #+FIXCONS LAB-HIGH-BIT #-FIXCONS (LIST LAB-HIGH-BIT))
  88.  
  89. (DECLARE-TOP(SPECIAL +S +SM +SL -S -SM -SL LABS LPRS LABINDEX LPRINDEX WORLD *))
  90.  
  91. ;; Macro for indirecting through the contents of a cell.
  92.  
  93. (DEFMACRO UNLAB (CELL) 
  94.       #+FIXCONS CELL #-FIXCONS `(CAR ,CELL))
  95.  
  96. (DEFMACRO SETQ-UNLAB (CELL)
  97.       #+FIXCONS NIL
  98.       #-FIXCONS `(SETQ ,CELL (UNLAB ,CELL)))
  99.  
  100. (DEFMACRO SETQ-COPYN (CELL)
  101.       #+FIXCONS NIL
  102.       #-FIXCONS `(SETQ ,CELL (COPYN ,CELL)))
  103.  
  104. ;; Conditionalize primitive functions used in this file.  These are in
  105. ;; LAP for Lisp implementations which cons fixnums.  This interface
  106. ;; is poorly designed since the meaning of COPYN is varies slightly
  107. ;; between systems.  In one case it means "take a cell and produce a
  108. ;; new one with the same contents".  In the other, it means "take an
  109. ;; immediate fixnum and return a cell containing it."  As a result of
  110. ;; this, #+FIXCONS conditionalizations appear in the actual source code.
  111.  
  112. #-FIXCONS
  113. (PROGN 'COMPILE
  114.   (DEFMACRO COPYN (N) `(LIST ,N))
  115.   (DEFMACRO IORM (CELL N)
  116.         `(RPLACA ,CELL (LOGIOR (CAR ,CELL) (CAR ,N))))
  117.   (DEFMACRO XORM (CELL N)
  118.         `(RPLACA ,CELL (LOGXOR (CAR ,CELL) (CAR ,N))))
  119.   )
  120.  
  121. (defun xxorm (cell n)
  122.   (xorm cell n))
  123. ;; The LAP for the PDP-10 version.
  124.  
  125. #+PDP10 (LAP-A-LIST '(
  126. (LAP COPYN SUBR)
  127. (MOVE TT 0 A)
  128. (JSP T FWCONS)
  129. (POPJ P)
  130. NIL
  131.  
  132. (LAP IORM SUBR)
  133. (MOVE B 0 B)
  134. (IORM B 0 A)
  135. (POPJ P)
  136. NIL
  137.  
  138. (LAP XORM SUBR)
  139. (MOVE B 0 B)
  140. (XORM B 0 A)
  141. (POPJ P)
  142. NIL ))
  143.  
  144. #+Franz
  145. (progn 'compile
  146.        (defmacro copyn (n) `(copyint* ,n))
  147.        (defmacro iorm (cell n) `(replace ,cell (logior ,cell ,n)))
  148.        (defmacro xorm (cell n) `(replace ,cell (logxor ,cell ,n))) )
  149.  
  150. (DEFPROP GLOBAL 1 CMARK)
  151. ;(eval-when ( load )
  152. ;(ARRAY CONUNMRK NIL (f1+ CONNUMBER))
  153. ;(ARRAY CONMARK T (f1+ CONNUMBER))
  154. ;)
  155.  
  156. (defvar CONUNMRK (*array NIL t (f1+ CONNUMBER)))
  157. (defvar CONMARK (*ARRAY nil  T (f1+ CONNUMBER)))
  158.  
  159. (DEFMFUN MARK (X) (PUTPROP X T 'MARK))
  160. (DEFMFUN MARKP (X) (AND (SYMBOLP X) (ZL-GET X 'MARK)))
  161.  
  162. ;;
  163. (defun zl-remprop (sym indicator)
  164.   (cond ((symbolp sym) (remprop sym indicator))
  165.     (t (remf (cdr sym) indicator))))
  166.  
  167. (DEFMFUN UNMRK (X) (zl-REMPROP X 'MARK))
  168.  
  169. (DEFUN MARKS (X) (COND ((NUMBERP X)) ((ATOM X) (MARK X)) (T (MAPC #'MARKS X))))
  170. (DEFUN UNMRKS (X)
  171.   (COND ((NUMBERP X))
  172.     ((OR (ATOM X) (NUMBERP (CAR X))) (UNMRK X))
  173.     (T (MAPC #'UNMRKS X))))
  174.  
  175. (progn 'compile
  176. (DEFMODE TYPE ()
  177.   (ATOM (SELECTOR +LABS) (SELECTOR -LABS) (SELECTOR DATA))
  178.   SELECTOR)
  179. (DEFMODE INDV ()
  180.   (ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR IN))
  181.   SELECTOR)
  182. (DEFMODE UNIV ()
  183.   (ATOM (SELECTOR =LABS) (SELECTOR NLABS) (SELECTOR DATA) (SELECTOR UN))
  184.   SELECTOR)
  185. (DEFMODE DATUM ()
  186.   (ATOM (SELECTOR ULABS) (SELECTOR CON) (SELECTOR WN))
  187.   SELECTOR)
  188. (DEFMODE CONTEXT ()
  189.   (ATOM (SELECTOR CMARK FIXNUM 0) (SELECTOR SUBC) (SELECTOR DATA)))
  190.  )
  191.  
  192.  
  193.  
  194.  
  195.  ;; Is (COPYN 0) really needed in these next four macros instead of simply 0?
  196. ;; If the fixnum were to get clobbered, then it would seem that (LIST 0) would
  197. ;; be the correct thing to return in the #-FIXCONS case. -cwh
  198.  
  199. (DEFMACRO +LABZ (X)
  200.   `(COND ((+LABS ,X))
  201.      (T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
  202.  
  203. (DEFMACRO -LABZ (X)
  204.   `(COND ((-LABS ,X))
  205.      (T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
  206.  
  207. (DEFMACRO =LABZ (X)
  208.   `(COND ((=LABS ,X))
  209.      (T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
  210.  
  211. (DEFMACRO NLABZ (X)
  212.   `(COND ((NLABS ,X))
  213.      (T #+FIXCONS (COPYN 0) #-FIXCONS '(0))))
  214.  
  215. (DEFMACRO ULABZ (X)
  216.   `(COND ((ULABS ,X))
  217.      (T #+FIXCONS 0 #-FIXCONS '(0))))
  218.  
  219. (DEFMACRO SUBP (&rest X)
  220.   #-FIXCONS (SETQ X (MAPCAR #'(LAMBDA (FORM) `(UNLAB ,FORM)) X))
  221.   `(= ,(CAR X) (LOGAND . ,X)))
  222.  
  223. (DEFUN DBNODE (X) (IF (SYMBOLP X) X (LIST X)))
  224. (DEFUN NODEP (X) (OR (ATOM X) (MNUMP (CAR X))))
  225. (DEFUN DBVARP (X) (GETL X '(UN EX)))
  226.  
  227. ;; Is this supposed to return a fixnum or a cell?
  228.  
  229. (DEFUN LAB (N) (LSH 1 (f1- N)))
  230.  
  231. (DEFUN LPR (M N)
  232.   (COND ((DO ((L LPRS (CDR L))) ((NULL L))
  233.          (IF (AND (LABEQ M (CAAAR L)) (LABEQ N (CDAAR L)))
  234.          (RETURN (CDAR L)))))
  235.     ((= (SETQ LPRINDEX (f1- LPRINDEX)) LABINDEX) (BREAK 'LPR T))
  236.     (T (SETQ LPRS (CONS (CONS (CONS M N) (LSH 1 LPRINDEX)) LPRS))
  237.        (CDAR LPRS))))
  238.  
  239. (DEFUN LABEQ (X Y) (EQUAL (LOGIOR X LAB-HIGH-BIT) (LOGIOR Y LAB-HIGH-BIT)))
  240.  
  241. (DEFUN MARKND (ND)
  242.   (COND ((+LABS ND))
  243.       ((= LPRINDEX (SETQ LABINDEX (f1+ LABINDEX))) (BREAK 'MARKND T))
  244.     (T (SETQ LABS (CONS (CONS ND (LAB LABINDEX)) LABS))
  245.        (BEG ND (LAB LABINDEX))
  246.        (CDAR LABS))))
  247.  
  248. (DEFUN DBV (X R)
  249.   (DECLARE (FIXNUM X R ))
  250.   (DO ((L LPRS (CDR L)) (Y 0)) ((NULL L) Y)
  251.       (declare (fixnum y))
  252.       (IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND X (CAAAR L)))))
  253.       (SETQ Y (LOGIOR (CDAAR L) Y)))))
  254.  
  255. (DEFUN DBA (R Y)
  256.   (DECLARE (FIXNUM  R Y ))
  257.   (DO ((L LPRS (CDR L)) (X 0)) ((NULL L) X)
  258.       (DECLARE (FIXNUM X ))
  259.       (IF (AND (NOT (= 0 (LOGAND R (CDAR L)))) (NOT (= 0 (LOGAND (CDAAR L) Y))))
  260.       (SETQ X (LOGIOR X (CAAAR L))))))
  261. #-cl
  262. (DEFUN PRLAB (X)
  263.   (SETQ-UNLAB X)
  264.   (SETQ X (LET ((*print-base* 2)) (EXPLODEN (BOOLE BOOLE-ANDC1 LAB-HIGH-BIT X))))
  265.   (DO ((I (fixnum-remainder (LENGTH X) 3) 3)) ((NULL X))
  266.       (DO ((J I (f1- J))) ((= 0 J)) (TYO (CAR X)) (SETQ X (CDR X)))
  267.       (TYO #\SPACE)))
  268.  
  269. #+cl
  270. (DEFUN PRLAB (X)
  271.   (SETQ-UNLAB X)
  272.   (SETQ X (LET ((*print-base* 2)(*read-base* 2))(and x (EXPLODEN (BOOLE BOOLE-ANDC1 LAB-HIGH-BIT X)))))
  273.   (DO ((I (fixnum-remainder (LENGTH X) 3) 3)) ((NULL X))
  274.       (DO ((J I (f1- J))) ((= 0 J)) (TYO (CAR X)) (SETQ X (CDR X)))
  275.       (TYO #\SPACE)))
  276.  
  277. (DEFUN ONP (CL LAB) (SUBP LAB (+LABZ CL)))
  278. (DEFUN OFFP (CL LAB) (SUBP LAB (-LABZ CL)))
  279. (DEFUN ONPU (LAB FACT) (SUBP LAB (ULABZ FACT)))
  280. (DEFMFUN VISIBLEP (DAT) (AND (NOT (ULABS DAT)) (CNTP DAT)))
  281.  
  282. (DEFUN CANCEL (LAB DAT)
  283.   (cond
  284.    ((SETQ * (ULABS DAT)) (IORM * LAB))
  285.    (t (SETQ ULABS (CONS DAT ULABS))
  286.       (SETQ-UNLAB LAB)
  287.       (PUTPROP DAT (COPYN LAB) 'ULABS))))
  288.  
  289. (DEFUN BEG (ND LAB)
  290.   (SETQ-COPYN LAB)
  291.   (IF (QUEUE+P ND LAB) 
  292.       (IF (NULL +S)
  293.       (SETQ +S (NCONS ND) +SM +S +SL +S)
  294.             (SETQ +S (CONS ND +S)))))
  295.  
  296. (DEFUN BEG- (ND LAB)
  297.   (SETQ-COPYN LAB)
  298.   (IF (QUEUE-P ND LAB)
  299.       (IF (NULL -S) (SETQ -S (NCONS ND) -SM -S -SL -S)
  300.             (SETQ -S (CONS ND -S)))))
  301.  
  302. (DEFUN MID (ND LAB)
  303.   (IF (QUEUE+P ND LAB)
  304.       (cond
  305.        ((NULL +SM) (SETQ +S (NCONS ND) +SM +S +SL +S))
  306.        (t (RPLACD +SM (CONS ND (CDR +SM)))
  307.       (IF (EQ +SM +SL) (SETQ +SL (CDR +SL)))
  308.       (SETQ +SM (CDR +SM))))))
  309.  
  310. (DEFUN MID- (ND LAB)
  311.   (IF (QUEUE-P ND LAB)
  312.       (cond
  313.        ((NULL -SM) (SETQ -S (NCONS ND) -SM -S -SL -S))
  314.        (t (RPLACD -SM (CONS ND (CDR -SM)))
  315.       (IF (EQ -SM -SL) (SETQ -SL (CDR -SL)))
  316.       (SETQ -SM (CDR -SM))))))
  317.  
  318. (DEFUN END (ND LAB)
  319.   (IF (QUEUE+P ND LAB)
  320.       (cond
  321.        ((NULL +SL) (SETQ +S (NCONS ND) +SM +S +SL +S))
  322.        (t (RPLACD +SL (NCONS ND))
  323.       (SETQ +SL (CDR +SL))))))
  324.  
  325. (DEFUN END- (ND LAB)
  326.   (IF (QUEUE-P ND LAB) 
  327.       (cond
  328.        ((NULL -SL) (SETQ -S (NCONS ND) -SM -S -SL -S))
  329.        (t (RPLACD -SL (NCONS ND))
  330.       (SETQ -SL (CDR -SL))))))
  331.  
  332. (DEFUN QUEUE+P (ND LAB)
  333.   (COND ((NULL (SETQ * (+LABS ND)))
  334.      (SETQ +LABS (CONS ND +LABS))
  335.      (SETQ-UNLAB LAB)
  336.      (PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '+LABS))
  337.     ((SUBP LAB *) NIL)
  338.     ((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
  339.     (T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
  340.  
  341. (DEFUN QUEUE-P (ND LAB)
  342.   (COND ((NULL (SETQ * (-LABS ND)))
  343.      (SETQ -LABS (CONS ND -LABS))
  344.      (SETQ-UNLAB LAB)
  345.      (PUT ND (COPYN (LOGIOR LAB-HIGH-BIT LAB)) '-LABS))
  346.     ((SUBP LAB *) NIL)
  347.     ((SUBP LAB-HIGH-LAB *) (IORM * LAB) NIL)
  348.     (T (IORM * (LOGIOR LAB-HIGH-BIT (UNLAB LAB))))))
  349.  
  350. (DEFUN DQ+ () 
  351.   (IF +S (PROG2 (xXORM (zl-get (car +s) '+labs) ;(+LABS (CAR +S))
  352.               LAB-HIGH-LAB)
  353.         (CAR +S)
  354.         (COND ((NOT (EQ +S +SM)) (SETQ +S (CDR +S)))
  355.               ((NOT (EQ +S +SL)) (SETQ +S (CDR +S) +SM +S))
  356.               (T (SETQ +S NIL +SM NIL +SL NIL))))))
  357.  
  358. (DEFUN DQ- ()
  359.   (IF -S (PROG2 (XORM (-LABS (CAR -S)) LAB-HIGH-LAB)
  360.         (CAR -S)
  361.         (COND ((NOT (EQ -S -SM)) (SETQ -S (CDR -S)))
  362.               ((NOT (EQ -S -SL)) (SETQ -S (CDR -S) -SM -S))
  363.               (T (setq -S NIL -SM NIL -SL NIL))))))
  364.  
  365. (DEFMFUN CLEAR ()
  366.   (IF DBTRACE (MTELL "~%Clearing ~A" MARKS))
  367.   (MAPC #'(LAMBDA (SYM) (_ (SEL SYM +LABS) NIL)) +LABS)
  368.   (MAPC #'(LAMBDA (SYM) (_ (SEL SYM -LABS) NIL)) -LABS)
  369.   (MAPC #'(LAMBDA (SYM) (ZL-REMPROP SYM 'ULABS)) ULABS)
  370.   (SETQ +S NIL +SM NIL +SL NIL -S NIL -SM NIL -SL NIL 
  371.     LABS NIL LPRS NIL LABINDEX 0 LPRINDEX LABNUMBER  
  372.     MARKS 0 +LABS NIL -LABS NIL ULABS NIL)
  373.   (CONTEXTMARK))
  374.  
  375. (DEFMFUN TRUEP (PAT)
  376.   (CLEAR)
  377.   (COND ((ATOM PAT) PAT)
  378.     ((PROG2 (SETQ PAT (MAPCAR #'SEMANT PAT)) NIL))
  379.     ((EQ (CAR PAT) 'KIND) (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 1) (PROPG))
  380.     (T (BEG (CADR PAT) 1) (BEG- (CADDR PAT) 2) (BEG (CAR PAT) (LPR 1 2)) (PROPG))))
  381.  
  382. (DEFMFUN FALSEP (PAT)
  383.   (CLEAR)
  384.   (COND ((EQ (CAR PAT) 'KIND)
  385.      (BEG (CADR PAT) 1) (BEG (CADDR PAT) 1) (PROPG))))
  386.  
  387. (DEFMFUN ISP (PAT) (COND ((TRUEP PAT)) ((FALSEP PAT) NIL) (T 'UNKNOWN)))
  388.  
  389. (DEFMFUN KINDP (X Y &aux #+lispm (default-cons-area working-storage-area ))
  390.   (IF (NOT (SYMBOLP X)) (MERROR "KINDP called on a non-symbolic atom."))
  391.   (CLEAR)
  392.   (BEG X 1)
  393.   (DO ((P (DQ+) (DQ+))) ((NULL P))
  394.       (IF (EQ Y P) (RETURN T) (MARK+ P (+LABS P)))))
  395.  
  396. (DEFMFUN TRUE* (PAT)
  397.   (LET ((DUM (SEMANT PAT))) (IF DUM (CNTXT (IND (NCONS DUM)) CONTEXT))))
  398.  
  399. (DEFMFUN FACT (FUN ARG VAL) (CNTXT (IND (DATUM (LIST FUN ARG VAL))) CONTEXT))
  400.  
  401. (DEFMFUN KIND (X Y &aux #+kcl (y y))
  402.   (SETQ Y (DATUM (LIST 'KIND X Y))) (CNTXT Y CONTEXT) (ADDF Y X))
  403.  
  404. (DEFMFUN PAR (S Y)
  405.   (SETQ Y (DATUM (LIST 'PAR S Y))) (CNTXT Y CONTEXT)
  406.   (MAPC #'(LAMBDA (LIS) (ADDF Y LIS)) S))
  407.  
  408. (DEFMFUN DATUM (PAT) (NCONS PAT))
  409.  
  410. (DEFUN IND (DAT)
  411.   (MAPC #'(LAMBDA (LIS) (IND1 DAT LIS)) (CDAR DAT))
  412.   (MAPC #'IND2 (CDAR DAT))
  413.   DAT)
  414.  
  415. (DEFUN IND1 (DAT PAT)
  416.   (COND ((NOT (NODEP PAT)) (MAPC #'(LAMBDA (LIS) (IND1 DAT LIS)) PAT))
  417.     ((OR (MARKP PAT) (EQ 'UNKNOWN PAT)))
  418.     (T (ADDF DAT PAT) (MARK PAT))))
  419.  
  420. (DEFUN IND2 (ND) (IF (NODEP ND) (UNMRK ND) (MAPC #'IND2 ND)))
  421.  
  422.  
  423. (DEFMFUN ADDF (DAT ND &aux #+lispm (default-cons-area working-storage-area ))
  424.      (_ (SEL ND DATA) (CONS DAT (SEL ND DATA))))
  425.  
  426. (DEFMFUN MAXIMA-REMF (DAT ND) (_ (SEL ND DATA) (FDEL DAT (SEL ND DATA))))
  427.  
  428. (DEFUN FDEL (FACT DATA)
  429.   (cond
  430.    ((AND (EQ (CAR FACT) (CAAAR DATA))
  431.      (EQ (CADR FACT) (CADAAR DATA))
  432.      (EQ (CADDR FACT) (CADDAAR DATA)))
  433.     (CDR DATA))
  434.    (t (DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
  435.       (SETQ D (CAADR DS))
  436.       (COND ((AND (EQ (CAR FACT) (CAR D))
  437.               (EQ (CADR FACT) (CADR D))
  438.               (EQ (CADDR FACT) (CADDR D)))
  439.          (_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
  440.          (RPLACD DS (CDDR DS)) (RETURN T))))
  441.       DATA)))
  442.  
  443. (DEFUN SEMANTICS (PAT) (IF (ATOM PAT) PAT (LIST (SEMANT PAT))))
  444.  
  445. (DEFUN DB-MNUMP (X)
  446.        (OR (NUMBERP X)
  447.        (AND (NOT (ATOM X))
  448.         (NOT (ATOM (CAR X)))
  449.         (MEMQ (CAAR X) '(RAT BIGFLOAT)))))       
  450.  
  451. (DEFUN SEMANT (PAT) 
  452.   (COND ((SYMBOLP PAT) (OR (ZL-GET PAT 'VAR) PAT))
  453.     ((DB-MNUMP PAT) (DINTNUM PAT))
  454.     (T (MAPCAR #'SEMANT PAT))))
  455.  
  456. (DEFMFUN DINTERNP (X)
  457.   (COND ((MNUMP X) (DINTNUM X)) 
  458.     ((ATOM X) X) 
  459.     ((ASSOL X DOBJECTS))))
  460.  
  461. (DEFMFUN DINTERN (X &aux #+lispm (default-cons-area working-storage-area ))
  462.   (COND ((MNUMP X) (DINTNUM X))
  463.     ((ATOM X) X)
  464.     ((ASSOL X DOBJECTS))
  465.     (T (SETQ DOBJECTS (CONS (DBNODE X) DOBJECTS))
  466.        (CAR DOBJECTS))))
  467.  
  468. (DEFUN DINTNUM (X)
  469.   (COND ((ASSOL X NOBJECTS))
  470.     ((PROGN (SETQ X (DBNODE X)) NIL))
  471.     ((NULL NOBJECTS) (SETQ NOBJECTS (LIST X)) X)
  472.     ((EQ '$POS (RGRP (CAR X) (CAAR NOBJECTS)))
  473.      (LET ((CONTEXT 'GLOBAL))
  474.           (FACT 'MGRP X (CAR NOBJECTS)))
  475.      (SETQ NOBJECTS (CONS X NOBJECTS))  X)
  476.     (T (DO ((LIS NOBJECTS (CDR LIS)) (CONTEXT '$GLOBAL))
  477.            ((NULL (CDR LIS))
  478.         (LET ((CONTEXT 'GLOBAL))
  479.              (FACT 'MGRP (CAR LIS) X)) (RPLACD LIS (LIST X)) X)
  480.            (COND ((EQ '$POS (RGRP (CAR X) (CAADR LIS)))
  481.               (LET ((CONTEXT 'GLOBAL))
  482.                (FACT 'MGRP (CAR LIS) X) (FACT 'MGRP X (CADR LIS)))
  483.               (RPLACD LIS (CONS X (CDR LIS)))
  484.               (RETURN X)))))))
  485.  
  486. (DEFMFUN DOUTERN (X) (IF (ATOM X) X (CAR X)))
  487.  
  488. (DEFMFUN UNTRUE (PAT)
  489.   (KILL (CAR PAT) (SEMANT (CADR PAT)) (SEMANT (CADDR PAT))))
  490.  
  491. (DEFMFUN KILL (FUN ARG VAL) (KILL2 FUN ARG VAL ARG) (KILL2 FUN ARG VAL VAL))
  492.  
  493. (DEFUN KILL2 (FUN ARG VAL CL)
  494.   (COND ((NOT (ATOM CL)) (MAPC #'(LAMBDA (LIS) (KILL2 FUN ARG VAL LIS)) CL))
  495.     ((NUMBERP CL))
  496.     (T (_ (SEL CL DATA) (KILL3 FUN ARG VAL (SEL CL DATA))))))
  497.  
  498. (DEFUN KILL3 (FUN ARG VAL DATA)
  499.        (cond
  500.     ((AND (EQ FUN (CAAAR DATA))
  501.           (EQ ARG (CADAAR DATA)) (EQ VAL (CADDAAR DATA)))
  502.      (CDR DATA))
  503.     (t (DO ((DS DATA (CDR DS)) (D)) ((NULL (CDR DS)))
  504.            (SETQ D (CAADR DS))
  505.            (cond
  506.         ((NOT (AND (EQ FUN (CAR D))
  507.                (EQ ARG (CADR D))
  508.                (EQ VAL (CADDR D))))
  509.          T)
  510.         (t (_ (SEL D CON DATA) (DELQ D (SEL D CON DATA)))
  511.            (RPLACD DS (CDDR DS)) (RETURN T))))
  512.        DATA)))
  513.  
  514. (DEFMFUN UNKIND (X Y)
  515.        (setq y (car (datum (LIST 'kind x y))))
  516.        (kcntxt y context)
  517.        (MAXIMA-REMF y x))
  518.  
  519. (defmfun remov (fact)
  520.        (remov4 fact (cadar fact))
  521.        (remov4 fact (caddar fact)))
  522.  
  523. (defun remov4 (fact cl)     
  524.   (cond ((or (symbolp cl)            ;if CL is a symbol or
  525.          (and (consp cl)            ;an interned number, then we want to REMOV4 FACT
  526.           (numberp (car cl))))        ;from its property list.
  527.      (_ (sel cl data) (delq fact (sel cl data))))
  528.     ((or (atom cl) (atom (car cl))))    ;if CL is an atom (not a symbol)
  529.                         ;or its CAR is an atom then we don't want to do
  530.                         ;anything to it.
  531.     (t (mapc #'(lambda (lis) (remov4 fact lis))
  532.          (cond ((atom (caar cl)) (cdr cl)) ;if CL's CAAR is
  533.                         ;an atom, then CL is an expression, and
  534.                         ;we want to REMOV4 FACT from the parts
  535.                         ;of the expression. 
  536.                ((atom (caaar cl)) (cdar cl)))))))
  537.                   ;if CL's CAAAR is an atom, then CL is a
  538.                   ;fact, and we want to REMOV4 FACT from
  539.                   ;the parts of the fact.
  540.  
  541. (DEFMFUN KILLFRAME (CL)
  542.        (MAPC #'REMOV (SEL CL DATA))
  543.        (ZL-REMPROP CL '+LABS) (ZL-REMPROP CL '-LABS)
  544.        (ZL-REMPROP CL 'OBJ) (ZL-REMPROP CL 'VAR)
  545.        (ZL-REMPROP CL 'FACT)
  546.        (ZL-REMPROP CL 'WN))
  547.  
  548. (DEFMFUN ACTIVATE N 
  549.   (DO ((I 1 (f1+ I))) ((> I N))
  550.       (cond
  551.        ((MEMQ (ARG I) CONTEXTS) NIL)
  552.        (t (SETQ CONTEXTS (CONS (ARG I) CONTEXTS))
  553.       (CMARK (ARG I))))))
  554.  
  555. (DEFMFUN DEACTIVATE N 
  556.   (DO ((I 1 (f1+ I))) ((> I N))
  557.       (cond
  558.        ((NOT (MEMQ (ARG I) CONTEXTS)) NIL)
  559.        (t (CUNMRK (ARG I))
  560.       (SETQ CONTEXTS (DELQ (ARG I) CONTEXTS))))))
  561.  
  562. (DEFMFUN CONTEXT N (NEWCON (LISTIFY N)))
  563.  
  564. (DEFUN NEWCON (C)
  565.   (IF (> CONINDEX CONNUMBER) (GCCON))
  566.   (SETQ C (IF (NULL C) (LIST '*GC NIL) (LIST '*GC NIL 'SUBC C)))
  567.   (store (AREF CONUNMRK CONINDEX) C)
  568.   (store (AREF CONMARK CONINDEX) (CDR C))
  569.   (SETQ CONINDEX (f1+ CONINDEX))
  570.   C)
  571.  
  572. ;; To be used with the WITH-NEW-CONTEXT macro.
  573. (DEFUN CONTEXT-UNWINDER ()
  574.   (KILLC (AREF CONMARK CONINDEX))
  575.   (SETQ CONINDEX (f1- CONINDEX))
  576.   (SETF (AREF CONUNMRK CONINDEX) ())
  577.   )
  578.  
  579. (DEFUN GCCON () 
  580.   (GCCON1)
  581.   (WHEN (> CONINDEX CONNUMBER)
  582.     #+GC (GC)
  583.     (GCCON1)
  584.     (WHEN (> CONINDEX CONNUMBER)
  585.           (MERROR "~%Too many contexts."))))
  586.  
  587. (DEFUN GCCON1 ()
  588.   (SETQ CONINDEX 0)
  589.   (DO ((I 0 (f1+ I))) ((> I CONNUMBER))
  590.       (cond
  591.        ((NOT (EQ (AREF CONMARK I) (CDR (AREF CONUNMRK I))))
  592.     (KILLC (AREF CONMARK I)))
  593.        (t (STORE (AREF CONUNMRK CONINDEX) (AREF CONUNMRK I))
  594.       
  595.       (STORE (AREF CONMARK CONINDEX) (AREF CONMARK I))
  596.       
  597.       (SETQ CONINDEX (f1+ CONINDEX))))))
  598.  
  599. (DEFMFUN CNTXT (DAT CON)
  600.   (IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
  601.   (PUT CON (CONS DAT (ZL-GET CON 'DATA)) 'DATA)
  602.   (IF (NOT (EQ 'GLOBAL CON)) (PUT DAT CON 'CON))
  603.   DAT)
  604.  
  605. (defmfun kcntxt (fact con)
  606.        (if (not (atom con)) (setq con (cdr con)))
  607.        (put con (fdel fact (zl-get con 'data)) 'data)
  608.        (if (not (eq 'global con)) (zl-remprop fact 'con))
  609.        fact)
  610.  
  611. (DEFUN CNTP (F)
  612.   (COND ((NOT (SETQ F (SEL F CON))))
  613.     ((SETQ F (ZL-GET F 'CMARK)) (> F 0))))
  614.  
  615. (DEFMFUN CONTEXTMARK (&aux #+lispm (default-cons-area working-storage-area ))
  616.   (LET ((CON CONTEXT))
  617.        (UNLESS (EQ CURRENT CON)
  618.            (CUNMRK CURRENT) (SETQ CURRENT CON) (CMARK CON))))
  619.  
  620. (DEFUN CMARK (CON)
  621.   (IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
  622.   (LET ((CM (ZL-GET CON 'CMARK)))
  623.     (PUTPROP CON (IF CM (f1+ CM) 1) 'CMARK)
  624.     (MAPC #'CMARK (ZL-GET CON 'SUBC))))
  625.  
  626. (DEFUN CUNMRK (CON)
  627.   (IF (NOT (ATOM CON)) (SETQ CON (CDR CON)))
  628.   (LET ((CM (ZL-GET CON 'CMARK)))
  629.        (COND (CM (PUTPROP CON (f1- CM) 'CMARK)))
  630.        (MAPC #'CUNMRK (ZL-GET CON 'SUBC))))
  631.  
  632. (DEFMFUN KILLC (CON)
  633.   (CONTEXTMARK)
  634.   (COND ((NOT (NULL CON))
  635.      (MAPC #'REMOV (ZL-GET CON 'DATA))
  636.      (ZL-REMPROP CON 'DATA)
  637.      (ZL-REMPROP CON 'CMARK)
  638.      (ZL-REMPROP CON 'SUBC)))
  639.   T)
  640.  
  641. (DEFUN PROPG ()
  642.   (DO ((X) (LAB)) (NIL)
  643.       (COND ((SETQ X (DQ+))
  644.          (SETQ LAB (+LABS X))
  645.          (IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (-LABZ X))))
  646.          (MARK+ X LAB) (RETURN T)))
  647.         ((SETQ X (DQ-))
  648.          (SETQ LAB (-LABS X))
  649.          (IF (= 0 (LOGAND (UNLAB LAB) (UNLAB (+LABZ X))))
  650.          (MARK- X LAB) (RETURN T)))
  651.         (T (RETURN NIL)))))
  652.  
  653. (DEFUN MARK+ (CL LAB &aux #+lispm (default-cons-area working-storage-area ))
  654.   (COND (DBTRACE (SETQ MARKS (f1+ MARKS))
  655.      (MTELL "~%Marking ~A +" CL) (PRLAB LAB)))
  656.   (MAPC #'(LAMBDA (LIS) (MARK+0 CL LAB LIS)) (SEL CL DATA)))
  657.  
  658. (DEFUN MARK+0 (CL LAB FACT)
  659.   (COND (DBCHECK (MTELL "~%Checking ~A from ~A+" (CAR FACT) CL) (PRLAB LAB)))
  660.   (COND ((ONPU LAB FACT))
  661.     ((NOT (CNTP FACT)))
  662.     ((NULL (SEL FACT WN)) (MARK+1 CL LAB FACT))
  663.     ((ONP (SEL FACT WN) WORLD) (MARK+1 CL LAB FACT))
  664.     ((OFFP (SEL FACT WN) WORLD) NIL)
  665.     (T (MARK+3 CL LAB FACT))))
  666.  
  667. (DEFUN MARK+1 (CL LAB DAT)
  668.   (COND ((EQ (CAAR DAT) 'KIND)
  669.      (IF (EQ (CADAR DAT) CL) (MID (CADDAR DAT) LAB)))  ; E1
  670.     ((EQ (CAAR DAT) 'PAR)
  671.      (IF (NOT (EQ (CADDAR DAT) CL))
  672.          (PROGN (CANCEL LAB DAT)  ; PR1
  673.             (MID (CADDAR DAT) LAB)
  674.             (DO ((LIS (CADAR DAT) (CDR LIS))) ((NULL LIS))
  675.                 (IF (NOT (EQ (CAR LIS) CL)) (MID- (CAR LIS) LAB))))))
  676.     ((EQ (CADAR DAT) CL)
  677.      (IF (+LABS (CAAR DAT))  ; V1
  678.          (END (CADDAR DAT) (DBV LAB (+LABS (CAAR DAT)))))
  679.      (IF (-LABS (CADDAR DAT))  ; F4
  680.          (END- (CAAR DAT) (LPR LAB (-LABS (CADDAR DAT))))))))
  681.  
  682. (DEFUN MARK+3 (CL LAB DAT) CL LAB ;Ignored
  683.   (IFN (= 0 (LOGAND (UNLAB (+LABZ (CADDAR DAT)))
  684.             (UNLAB (DBV (+LABZ (CADAR DAT)) (-LABZ (CAAR DAT))))))
  685.        (BEG- (SEL DAT WN) WORLD)))
  686.  
  687.  
  688. (DEFUN MARK- (CL LAB &aux #+lispm (default-cons-area working-storage-area ))
  689.   (WHEN DBTRACE
  690.     (SETQ MARKS (f1+ MARKS)) (MTELL "Marking ~A -" CL) (PRLAB LAB))
  691.   (MAPC #'(LAMBDA (LIS) (MARK-0 CL LAB LIS)) (SEL CL DATA)))
  692.  
  693. (DEFUN MARK-0 (CL LAB FACT)
  694.   (WHEN DBCHECK (MTELL "~%Checking ~A from ~A-" (CAR FACT) CL) (PRLAB LAB))
  695.   (COND ((ONPU LAB FACT))
  696.     ((NOT (CNTP FACT)))
  697.     ((NULL (SEL FACT WN)) (MARK-1 CL LAB FACT))
  698.     ((ONP (SEL FACT WN) WORLD) (MARK-1 CL LAB FACT))
  699.     ((OFFP (SEL FACT WN) WORLD) NIL)))
  700.  
  701. (DEFUN MARK-1 (CL LAB DAT  &aux #+lispm (default-cons-area working-storage-area ))
  702.   (COND ((EQ (CAAR DAT) 'KIND)
  703.      (IF (NOT (EQ (CADAR DAT) CL)) (MID- (CADAR DAT) LAB)))  ; E4
  704.     ((EQ (CAAR DAT) 'PAR)
  705.      (IF (EQ (CADDAR DAT) CL)
  706.          (PROG2 (CANCEL LAB DAT)  ; S4
  707.             (DO ((LIS (CADAR DAT) (CDR LIS))) ((NULL LIS)) (MID- (CAR LIS) LAB)))
  708.          (PROGN (SETQ-UNLAB LAB)  ; ALL4
  709.             (DO ((LIS (CADAR DAT) (CDR LIS))) ((NULL LIS))
  710.                 (SETQ LAB (LOGAND (UNLAB (-LABZ (CAR LIS))) LAB)))
  711.             (SETQ-COPYN LAB)
  712.             (CANCEL LAB DAT)
  713.             (MID- (CADDAR DAT) LAB))))
  714.     ((EQ (CADDAR DAT) CL)
  715.      (IF (+LABS (CAAR DAT))  ; A2
  716.          (END- (CADAR DAT) (DBA (+LABS (CAAR DAT)) LAB)))
  717.      (IF (+LABS (CADAR DAT))  ; F6
  718.          (END- (CAAR DAT) (LPR (+LABS (CADAR DAT)) LAB))))))
  719.  
  720. ;         in out                    in out                  ins  in out
  721. ;    -----------        -------------             ----------------
  722. ;    E1 |     +        INV1 |     +              AB1 |(+)  +   +
  723. ;    E2 |     -        INV2 |     -              AB2 |(+)  -   +
  724. ;    E3 | +            INV3 | +                  AB3 |(+)  +   -
  725. ;    E4 | -            INV4 | -                  AB4 |(+)  -   -
  726. ;                                                         AB5 |(-)  +   +
  727. ;            in out                    in out             AB6 |(-)  -   +
  728. ;       -----------             -------------             AB7 |(-)  +   -
  729. ;       S1 |    (+)             ALL1 |(+)  +              AB8 |(-)  -   -
  730. ;       S2 |    (-)             ALL2 |(+)  -
  731. ;       S3 |(+)                 ALL3 |(-)  +
  732. ;       S4 |(-)                 ALL4 |(-)  -
  733.  
  734.  
  735.  
  736. ;         in rel out             in rel out         in rel out
  737. ;    ---------------        ---------------    ---------------
  738. ;    V1 |    (+)  +        A1 | +  (+)        F1 |     +  (+)
  739. ;    V2 |    (+)  -        A2 | -  (+)        F2 |     +  (-)
  740. ;    V3 |    (-)  +        A3 | +  (-)        F3 |     -  (+)
  741. ;    V4 |    (-)  -        A4 | -  (-)        F4 |     -  (-)
  742. ;                        F5 |(+)  +
  743. ;                        F6 |(+)  -
  744. ;                        F7 |(-)  +
  745. ;                        F8 |(-)  -
  746.  
  747.  
  748. (DEFUN UNI (P1 P2 AL)
  749.   (COND ((DBVARP P1) (DBUNIVAR P1 P2 AL))
  750.     ((NODEP P1)
  751.      (COND ((DBVARP P2) (DBUNIVAR P2 P1 AL))
  752.            ((NODEP P2) (IF (EQ P1 P2) AL))))
  753.     ((DBVARP P2) (DBUNIVAR P2 P1 AL))
  754.     ((NODEP P2) NIL)
  755.     ((SETQ AL (UNI (CAR P1) (CAR P2) AL)) (UNI (CDR P1) (CDR P2) AL))))
  756.  
  757. (DEFUN DBUNIVAR (P V AL)
  758.   (LET ((DUM (ASSQ P AL)))
  759.     (COND ((NULL DUM) (CONS (CONS P V) AL))
  760.       (T (UNI (CDR DUM) V AL)))))
  761.  
  762. ; Undeclarations for the file:
  763.  
  764. #-NIL
  765. (DECLARE-TOP(NOTYPE LAB))
  766.